Methods

library(tidyverse)
library(ggdist)
library(ggside)
library(easystats)
library(patchwork)
library(brms)

df <- read.csv("data/data.csv") |>
  mutate(
    Date = lubridate::dmy(Date),
    Participant = fct_reorder(Participant, Date),
    Screen_Refresh = as.character(Screen_Refresh),
    Education = fct_relevel(Education, "Doctorate", "Master", "Bachelor", "High School", "Other", "Prefer not to Say"),
    Belief = fct_relevel(Belief, "Fake", "Real"),
    Stimulus_Interest = case_when(
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Opposite" ~ TRUE,
      Sexual_Orientation == "Heterosexual" & Stimulus_SameSex == "Same" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Opposite" ~ FALSE,
      Sexual_Orientation == "Homosexual" & Stimulus_SameSex == "Same" ~ TRUE,
      Sexual_Orientation %in% c("Bisexual", "Queer") ~ TRUE,
      TRUE ~ NA
    )
  )


# head(df[is.na(df$Stimulus_Attract), ])

# Create individual scores for Simulation Monitoring
df <- df |>
  group_by(Participant, Belief) |>
  summarise(
    Confidence = mean(abs(Belief_Confidence)),
    n = n() / 109
  ) |>
  pivot_wider(names_from = "Belief", values_from = c("Confidence", "n")) |>
  ungroup() |>
  merge(df, by = "Participant")

Exclusions

outliers <- c(
  # Very short duration for questionnaire in particular + low rating correlations
  "5eaef8702b68455d6e130595_ptsga",
  "5f0f0a2a8b2a480447f31b21_lqgpz",
  "611d03b822d4c8e041ea0c32_m0knb"
)
outliers_partial <- c(
  "5dc3485219ca0326027ce91f_37ho9",
  "5c6414540821d30001046198_x9q7r",
  "60dd7b03f1e72d38230df476_9yh9n",
  "5962799cb752840001ca478b_jh4sl",
  "5f44c23fbf2ddb80bcdf0edc_dnbny",
  "5e80370d48b5f47170e30e5c_5w2gf"
)

We removed 3 participants upon inspection of…

Extreme Items

extreme_items <- df |>
  group_by(Stimulus, Belief) |>
  summarize(n = n() / length(unique(df$Participant))) |>
  pivot_wider(values_from = "n", names_from = "Belief") |>
  mutate(File = paste0("experiment/stimuli/AMFD/", Stimulus)) |>
  arrange(Real) |>
  filter(Real < 0.15 | Real > 0.85)


p_item <- df |>
  filter(Stimulus %in% extreme_items$Stimulus) |>
  mutate(Stimulus = fct_relevel(Stimulus, as.character(extreme_items$Stimulus))) |>
  ggplot(aes(x = Belief_Answer, y = Stimulus, fill = Stimulus)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups") +
  geom_vline(xintercept = 0, linetype = "dotted") +
  ggimage::geom_image(data = extreme_items, aes(image = File, x = 0, y = Stimulus), size = 0.1, by = "height") +
  # scale_y_discrete(expand = c(0.5, 0.5)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-1, 0, 1),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d(option = "inferno") +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    # axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  )
# p_item


df <- df |>
  filter(!Stimulus %in% extreme_items$Stimulus)

We removed 1 trials per participant.

Attention Checks and Duration

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, starts_with("Attention"), starts_with("Duration"), n_Fake) |>
  slice(1) |>
  ungroup() |>
  rowwise() |>
  mutate(Attention_Check = mean(c(Attention_Check1, Attention_Check2, Attention_Check3))) |>
  ungroup() |>
  arrange(Attention_Check)

Ratings

dfsub$r_Trustworthy <- NA
dfsub$r_Attractive <- NA
dfsub$r_Beauty <- NA
for (participant in dfsub$Participant) {
  dfsub[dfsub$Participant == participant, "r_Trustworthy"] <- cor(df[df$Participant == participant, "Trustworthy"], df[df$Participant == participant, "Norms_Trustworthy"])
  dfsub[dfsub$Participant == participant, "r_Attractive"] <- cor(df[df$Participant == participant, "Attractive"], df[df$Participant == participant, "Norms_Attractive"])
  dfsub[dfsub$Participant == participant, "r_Beauty"] <- cor(df[df$Participant == participant, "Beauty"], df[df$Participant == participant, "Norms_Attractive"])
}

Summary

data.frame(Participant = c(paste0("Total (n=", nrow(dfsub), ")")), t(sapply(dfsub[2:ncol(dfsub)], mean, na.rm = TRUE))) |>
  rbind(dfsub) |>
  mutate(Attention_Check = paste0(
    insight::format_value(Attention_Check, 1),
    " (", insight::format_value(Attention_Check1, 1),
    ", ",
    insight::format_value(Attention_Check2, 1),
    ", ",
    insight::format_value(Attention_Check3, 1),
    ")"
  )) |>
  select(-Attention_Check1, -Attention_Check2, -Attention_Check3) |>
  datawizard::data_relocate("Attention_Check", 2) |>
  knitr::kable() |>
  kableExtra::row_spec(1, italic = TRUE) |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers) + 1, background = "#EF9A9A") |>
  kableExtra::row_spec(which(dfsub$Participant %in% outliers_partial) + 1, background = "#FFCC80")

Participant	Attention_Check	Duration_Questionnaires	Duration_Task	n_Fake	r_Trustworthy	r_Attractive	r_Beauty
Total (n=103)	1.0 (1.0, 1.0, 1.0)	12.09	23.7	0.445	0.268	0.442	0.465
611d03b822d4c8e041ea0c32_m0knb	0.6 (0.6, 0.4, 0.6)	6.00	20.5	0.248	0.164	0.208	0.225
5f0f0a2a8b2a480447f31b21_lqgpz	0.6 (0.2, 1.0, 0.5)	164.70	17.6	0.642	-0.144	0.343	0.288
5962799cb752840001ca478b_jh4sl	0.7 (1.0, 0.2, 1.0)	19.93	30.4	0.284	0.063	0.344	0.326
5dc3485219ca0326027ce91f_37ho9	0.8 (0.5, 1.0, 1.0)	7.01	16.1	0.587	0.253	0.572	0.557
5c6414540821d30001046198_x9q7r	0.9 (1.0, 1.0, 0.6)	9.84	23.4	0.284	0.330	0.483	0.466
60dd7b03f1e72d38230df476_9yh9n	0.9 (0.6, 1.0, 1.0)	12.86	19.9	0.092	0.435	0.429	0.550
5f44c23fbf2ddb80bcdf0edc_dnbny	0.9 (0.7, 1.0, 1.0)	4.71	24.8	0.486	0.103	0.147	0.195
5e80370d48b5f47170e30e5c_5w2gf	0.9 (0.7, 1.0, 1.0)	5.64	22.8	0.440	0.350	0.604	0.612
5fb7cfde7808523cea8ee891_xlrlw	1.0 (0.9, 1.0, 1.0)	6.95	17.7	0.514	0.324	0.515	0.532
613e4bf960ca68f8de00e5e7_cfsdt	1.0 (0.9, 1.0, 1.0)	11.15	23.8	0.468	0.265	0.466	0.428
6115d9fa61078b29b8db91ff_ewn8c	1.0 (0.9, 1.0, 1.0)	11.06	19.3	0.440	0.452	0.250	0.341
5f1acd8cb55680224c3d452a_56nun	1.0 (0.9, 1.0, 1.0)	11.66	26.0	0.642	0.383	0.527	0.518
5b8646582c180900019c9eb7_xt3l6	1.0 (1.0, 1.0, 1.0)	20.16	21.4	0.514	0.308	0.363	0.338
5d936374253d0a0017f32d96_n98qu	1.0 (1.0, 1.0, 1.0)	6.87	13.3	0.440	0.233	0.455	0.457
611b86fe4bd6db6f42e4afea_4asue	1.0 (1.0, 1.0, 1.0)	17.36	36.8	0.330	0.421	0.279	0.365
5f233d7f53212b0e22bf055d_x9368	1.0 (1.0, 1.0, 1.0)	13.32	16.7	0.624	0.430	0.603	0.619
5fb015142942a535524f55fc_u1vq2	1.0 (1.0, 1.0, 1.0)	14.47	18.4	0.624	0.428	0.575	0.598
5d7f8ffae664ab001967d9d3_7mrcg	1.0 (1.0, 1.0, 1.0)	4.83	11.5	0.468	0.306	0.209	0.361
613a92a2dbedc6e7aad89199_thehb	1.0 (1.0, 1.0, 1.0)	10.85	40.0	0.541	0.305	0.462	0.456
5ad63c167f70c10001904bc5_ers7p	1.0 (1.0, 1.0, 1.0)	12.18	25.6	0.413	0.298	0.466	0.521
5bb511c6689fc5000149c703_d9k0p	1.0 (1.0, 1.0, 1.0)	12.56	21.8	0.083	0.405	-0.168	0.351
5d40a12f4994c40001e4b80c_2ytoa	1.0 (1.0, 1.0, 1.0)	13.25	21.8	0.587	0.338	0.609	0.521
5eaef8702b68455d6e130595_ptsga	1.0 (1.0, 1.0, 1.0)	2.69	14.9	0.523	0.021	0.091	0.096
5eb17f5f5b4ec12749a65a24_cmop5	1.0 (1.0, 1.0, 1.0)	11.40	18.9	0.450	0.358	0.362	0.514
5ed8e10d54fe053fbc756c72_zknp4	1.0 (1.0, 1.0, 1.0)	7.63	26.3	0.468	-0.056	0.540	0.444
5f034ecf38c5aa527d056830_2pvm9	1.0 (1.0, 1.0, 1.0)	10.09	19.0	0.339	0.274	0.564	0.539
5f3801b18c88962be7831304_ubcua	1.0 (1.0, 1.0, 1.0)	8.73	16.8	0.330	0.153	0.578	0.558
5faa6cab8ac7a937a5240fcb_xsbot	1.0 (1.0, 1.0, 1.0)	10.20	14.9	0.505	0.153	0.544	0.517
601941db6605160008690742_twd28	1.0 (1.0, 1.0, 1.0)	6.25	13.9	0.578	0.299	0.453	0.444
6036ab8b13ac9c79d7e67e81_ln8ep	1.0 (1.0, 1.0, 1.0)	7.14	13.4	0.651	0.273	0.265	0.312
60a256f83ef6ada5debc47a9_q7wl4	1.0 (1.0, 1.0, 1.0)	6.03	16.0	0.321	0.218	0.520	0.451
60a3a03bc01ba594c9cca88d_v0jdv	1.0 (1.0, 1.0, 1.0)	11.76	30.0	0.495	0.406	0.258	0.410
60b6c415dbda3236ea22455a_dmezs	1.0 (1.0, 1.0, 1.0)	24.73	43.0	0.450	0.263	0.628	0.613
60e1eb72b81681d6c856bd7b_uzbeq	1.0 (1.0, 1.0, 1.0)	8.62	20.8	0.706	0.439	0.631	0.435
60e4b1dcd0eedab1e11019d1_4varz	1.0 (1.0, 1.0, 1.0)	8.61	33.0	0.349	0.191	0.368	0.388
60f3261b934093c881b85cf6_lnoph	1.0 (1.0, 1.0, 1.0)	13.37	27.8	0.450	0.225	0.520	0.575
611b1c9ce8ad1ac6db791065_hwlhj	1.0 (1.0, 1.0, 1.0)	8.57	26.1	0.541	0.364	0.231	0.525
613a972033d79df11a6570de_1u773	1.0 (1.0, 1.0, 1.0)	14.71	26.2	0.450	0.209	0.666	0.635
613baa22050360ec21d4437f_9sac0	1.0 (1.0, 1.0, 1.0)	16.64	17.6	0.688	0.106	0.195	0.178
614f681bacfa57e3d06529ad_qv0u7	1.0 (1.0, 1.0, 1.0)	15.65	30.0	0.404	0.256	0.427	0.417
6160f3629ac70cba36523ff8_zslcv	1.0 (1.0, 1.0, 1.0)	9.14	23.4	0.523	0.366	0.416	0.444
5c00043a6d931200019bcb9b_wnj27	1.0 (1.0, 1.0, 1.0)	20.36	34.7	0.284	0.543	0.582	0.634
5d3f63a92df9f7001bd92a32_oj5t7	1.0 (1.0, 1.0, 1.0)	7.93	20.1	0.523	0.193	0.390	0.431
5db9b910001ffa0188426dca_knhee	1.0 (1.0, 1.0, 1.0)	6.05	25.5	0.596	0.134	0.169	0.148
5ecd37ee75736a068808fa6c_v4ej4	1.0 (1.0, 1.0, 1.0)	10.52	16.0	0.468	0.217	0.612	0.536
5fdfd04b9bf07d83b2e5f780_gtb9u	1.0 (1.0, 1.0, 1.0)	9.30	20.6	0.147	0.222	0.657	0.620
6107133e49bf8db00bd6d389_qkj9f	1.0 (1.0, 1.0, 1.0)	11.38	29.6	0.477	0.366	0.299	0.579
613a69d8ed1c11f70b3d37c7_yu0z2	1.0 (1.0, 1.0, 1.0)	11.16	28.9	0.477	0.235	0.372	0.415
6146385561e8f95ff4f3b5d6_cvm6o	1.0 (1.0, 1.0, 1.0)	9.13	24.9	0.642	0.197	0.405	0.346
614b55e22ff3944a165736bb_cl98h	1.0 (1.0, 1.0, 1.0)	14.66	22.6	0.450	0.441	0.580	0.514
616cb46402d68cdfc6e8c8db_xzyj4	1.0 (1.0, 1.0, 1.0)	4.59	25.4	0.211	0.000	0.217	0.188
6294ce94ea81c4554b141010_u5v5t	1.0 (1.0, 1.0, 1.0)	8.28	18.7	0.339	0.294	0.491	0.461
558fa9dffdf99b7ce2924662_58ffp	1.0 (1.0, 1.0, 1.0)	10.06	34.9	0.624	0.314	0.451	0.470
572b96ba3ab9df000dbb4461_bq660	1.0 (1.0, 1.0, 1.0)	14.16	16.5	0.202	0.059	0.513	0.540
57b8e70f35624400013d690c_boeew	1.0 (1.0, 1.0, 1.0)	5.71	19.7	0.440	0.402	0.550	0.589
59501095c58c85000101dc57_od0ny	1.0 (1.0, 1.0, 1.0)	5.81	26.6	0.541	0.377	0.495	0.458
595bd5c85ae9a80001ce3426_32tr4	1.0 (1.0, 1.0, 1.0)	8.43	19.4	0.413	0.259	0.477	0.549
5a7875355292b80001227f63_uh6o3	1.0 (1.0, 1.0, 1.0)	11.53	24.4	0.450	0.399	0.513	0.474
5baf6705848bbd0001d6fc8a_kahs0	1.0 (1.0, 1.0, 1.0)	12.03	32.5	0.486	0.266	0.482	0.531
5c573e54e9813700018acc31_kv5lw	1.0 (1.0, 1.0, 1.0)	6.72	23.6	0.514	0.342	0.415	0.396
5dbd7193e8add82b72d795f2_8g8wk	1.0 (1.0, 1.0, 1.0)	11.12	22.9	0.266	0.461	0.577	0.624
5de476f9b5b7ff447db5c4aa_chlcj	1.0 (1.0, 1.0, 1.0)	10.25	17.6	0.468	0.307	0.514	0.459
5e7bcff00fb32c0f51fea882_bvbwo	1.0 (1.0, 1.0, 1.0)	15.14	19.2	0.229	0.207	0.485	0.490
5e8dddaf3d1b57068b77b2f2_8ebal	1.0 (1.0, 1.0, 1.0)	12.53	32.1	0.404	0.507	0.540	0.636
5eb170206e577a07e9954c65_csm2p	1.0 (1.0, 1.0, 1.0)	15.61	23.0	0.459	0.477	0.688	0.718
5ece75528f582a08555e0a3e_21ckq	1.0 (1.0, 1.0, 1.0)	13.74	48.5	0.523	0.453	0.500	0.613
5ef0a866cd9cde0fcd0d2f77_rvy90	1.0 (1.0, 1.0, 1.0)	10.57	26.2	0.532	0.200	0.599	0.597
5f09068244f84c18faaa74bc_q0ukp	1.0 (1.0, 1.0, 1.0)	6.97	19.3	0.450	-0.031	0.467	0.496
5f108dea719866356702d26f_p836j	1.0 (1.0, 1.0, 1.0)	5.29	17.4	0.422	-0.226	0.413	0.422
5f49424d243bb347aaec4897_ggzqw	1.0 (1.0, 1.0, 1.0)	8.61	25.3	0.303	0.434	0.518	0.475
5f5e7de4c81d3672642cd612_hpyto	1.0 (1.0, 1.0, 1.0)	7.09	19.1	0.532	0.269	0.524	0.300
5f600669b846780f0fe45709_erd2u	1.0 (1.0, 1.0, 1.0)	13.40	31.0	0.514	0.310	0.587	0.645
5f761e5106b786071f45b4aa_78zle	1.0 (1.0, 1.0, 1.0)	11.56	27.8	0.385	0.048	0.207	0.219
5f7ebad5cf009c196fd54b2b_d68uh	1.0 (1.0, 1.0, 1.0)	8.39	15.6	0.495	0.404	0.674	0.659
5f97e6601f6d0e016087fc91_h6pvt	1.0 (1.0, 1.0, 1.0)	4.71	26.9	0.239	0.051	0.166	0.289
5f9aba6600cdf11f1c9b915c_cakh2	1.0 (1.0, 1.0, 1.0)	26.74	46.8	0.394	0.266	0.325	0.357
5fb633dfaeda3f0aa05eefad_4t92s	1.0 (1.0, 1.0, 1.0)	8.18	18.1	0.505	0.289	0.521	0.499
5ff4a242cbe069bc27d9278b_relyq	1.0 (1.0, 1.0, 1.0)	6.51	14.0	0.183	0.225	0.572	0.540
603f6e643234e512fc197ae1_vowxj	1.0 (1.0, 1.0, 1.0)	11.40	32.7	0.486	0.304	0.538	0.281
6045cb37ffdadc70e734a73b_ns96q	1.0 (1.0, 1.0, 1.0)	17.87	52.2	0.541	0.448	0.427	0.429
604b169fe4b7991ec08da3a6_9o72l	1.0 (1.0, 1.0, 1.0)	7.21	23.4	0.330	0.111	0.456	0.419
605a1c7fe0ca143242990e95_528pg	1.0 (1.0, 1.0, 1.0)	13.97	23.1	0.560	0.388	0.491	0.526
6081728972120aa7f9685791_aqvhb	1.0 (1.0, 1.0, 1.0)	25.43	41.3	0.578	0.312	0.494	0.573
6099df8e57bf74dbc121c774_5jnsc	1.0 (1.0, 1.0, 1.0)	6.22	26.6	0.459	0.510	0.502	0.512
60a6ba026f8bd75b67b23c97_z458q	1.0 (1.0, 1.0, 1.0)	11.75	14.6	0.596	0.241	0.475	0.518
60b8b5dcb46db8ae98d0b047_4u9jy	1.0 (1.0, 1.0, 1.0)	4.86	21.4	0.367	0.151	-0.220	0.445
60cefa69352cbf2549f2bf35_as90e	1.0 (1.0, 1.0, 1.0)	8.50	19.2	0.486	0.513	0.539	0.520
60ddfb3db6a71ad9ba75e387_u85bv	1.0 (1.0, 1.0, 1.0)	8.48	14.7	0.550	0.068	0.502	0.435
61081aab1dad0a92827a371d_bbpfc	1.0 (1.0, 1.0, 1.0)	8.87	21.6	0.486	0.285	0.561	0.532
61093d97f7bf8a4f8117eb82_yzsmx	1.0 (1.0, 1.0, 1.0)	13.15	24.5	0.550	0.122	0.259	0.316
610d97bf0ee9babdb89986ea_3t039	1.0 (1.0, 1.0, 1.0)	8.71	20.4	0.450	0.527	0.584	0.556
61253683f41abc76c81ec082_xc4uu	1.0 (1.0, 1.0, 1.0)	7.45	19.6	0.294	0.346	0.559	0.546
612ba6c594a6d54154a88ae7_m0duf	1.0 (1.0, 1.0, 1.0)	6.73	12.5	0.339	0.513	0.508	0.445
61330f324c6c15a907dc2706_zg72v	1.0 (1.0, 1.0, 1.0)	9.53	28.0	0.404	0.252	0.432	0.495
613af39692992acbacdbbbbc_0g94n	1.0 (1.0, 1.0, 1.0)	17.26	39.3	0.394	0.112	0.458	0.518
6151a21b24b1ef1bc130b97d_cazbl	1.0 (1.0, 1.0, 1.0)	14.07	24.8	0.615	0.050	0.371	0.359
61545919a17f1331cb7b33a7_mszfq	1.0 (1.0, 1.0, 1.0)	12.28	20.4	0.018	0.182	0.359	0.376
61687ebcd2a35ffb762d1928_0hgcq	1.0 (1.0, 1.0, 1.0)	13.01	40.4	0.413	0.299	0.496	0.557
616e5ae706e970fe0aff99b6_561t0	1.0 (1.0, 1.0, 1.0)	6.15	25.2	0.624	0.453	0.548	0.497
6266a4e5846e1e41812a0432_ds50m	1.0 (1.0, 1.0, 1.0)	6.33	16.5	0.477	0.201	0.502	0.488
62e416f154e4c9e7f39d5cf7_2a9nx	1.0 (1.0, 1.0, 1.0)	6.52	9.3	0.468	0.089	0.434	0.443
5ec554706960444f4a1768de_uma91	1.0 (1.0, 1.0, 1.0)	8.58	16.4	0.248	-0.142	0.188	0.513
610aa32712b5d159232e01ca_2qade	1.0 (1.0, 1.0, 1.0)	6.85	20.9	0.523	0.403	0.548	0.556

# kableExtra::row_spec(which(str_detect(dfsub$Participant, "613a972033d79df11a6570de")) + 1, background = "green")

p_att <- dfsub |>
  select(Participant, starts_with("Att")) |>
  pivot_longer(-Participant) |>
  # mutate(name = str_remove(name, "Cor_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  scale_color_manual(values = c("black", "#2196F3", "#3F51B5", "#673AB7")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Score", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_time <- dfsub |>
  select(Participant, starts_with("Duration")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "Duration_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#4CAF50", "#FF9800")) +
  scale_color_manual(values = c("#4CAF50", "#FF9800")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(angle = 45, hjust = 1),
    legend.position = "top"
  ) +
  labs(y = "Duration (min)", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

p_cor <- dfsub |>
  select(Participant, starts_with("r_")) |>
  pivot_longer(-Participant) |>
  mutate(name = str_remove(name, "r_")) |>
  ggplot(aes(x = Participant, y = value)) +
  geom_bar(aes(fill = name), stat = "identity", position = "dodge") +
  scale_y_continuous(expand = c(0, 0)) +
  scale_fill_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  scale_color_manual(values = c("#F44336", "#9C27B0", "#5227b0")) +
  see::theme_modern() +
  theme(
    axis.text.x = element_text(
      angle = 45, hjust = 1,
      color = ifelse(levels(dfsub$Participant) %in% outliers, "red", ifelse(levels(dfsub$Participant) %in% outliers_partial, "orange", "black"))
    ),
    legend.position = "top"
  ) +
  labs(y = "Correlation", fill = "") +
  guides(color = "none") +
  ggside::geom_ysidedensity(aes(x = after_stat(scaled), color = name)) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0))

(p_att + theme(axis.text.x = element_blank())) /
  (p_time + theme(axis.text.x = element_blank())) /
  (p_cor)


df <- df |>
  filter(!Participant %in% outliers)

Participants

dfsub <- df |>
  group_by(Participant) |>
  select(Participant, Age, Sex, Sexual_Orientation, Ethnicity, Education, Nationality, Device_OS, starts_with("Screen"), starts_with("IPIP"), starts_with("Social_"), starts_with("FFNI_"), starts_with("GPTS_"), starts_with("IUS_"), starts_with("SelfAttractiveness"), starts_with("AI"), n_Real, Confidence_Fake, Confidence_Real) |>
  slice(1) |>
  ungroup()

The final sample included 100 participants (Mean age = 27.9, SD = 8.5, range: [19, 66]; Sex: 48.0% females, 52.0% males, 0.0% other; Education: Doctorate, 2.00%; Master, 18.00%; Bachelor, 34.00%; High School, 40.00%; Other, 5.00%; Prefer not to Say, 1.00%).

plot_distribution <- function(dfsub, what = "Age", title = what, subtitle = "", fill = "orange") {
  dfsub |>
    ggplot(aes_string(x = what)) +
    geom_density(fill = fill) +
    scale_x_continuous(expand = c(0, 0)) +
    scale_y_continuous(expand = c(0, 0)) +
    ggtitle(title, subtitle = subtitle) +
    theme_modern() +
    theme(
      plot.title = element_text(face = "bold", hjust = 0.5),
      plot.subtitle = element_text(face = "italic", hjust = 0.5),
      axis.title.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
}

plot_waffle <- function(dfsub, what = "Nationality", title = what, rows = 10, size = 4) {
  # library(emojifont)
  ggwaffle::waffle_iron(dfsub, what, rows = rows) |>
    # mutate(label = emojifont::fontawesome('fa-smiley')) |>
    # mutate(label = emojifont::emoji('smiley')) |>
    ggplot(aes(x, y)) +
    geom_point(aes(color = group), shape = "square", size = size) +
    # ggwaffle::geom_waffle(color = "white") +
    # geom_point() +
    # geom_text(aes(color=group ,label=label), family='fontawesome-webfont', size=4) +
    # geom_text(aes(color=group ,label=label), family='EmojiOne', size=4) +
    coord_equal() +
    ggtitle(title) +
    labs(fill = "", color = "") +
    # scale_x_continuous(expand = c(0, 0)) +
    # scale_y_continuous(expand = c(0, 0)) +
    theme_void() +
    # ggwaffle::theme_waffle() +
    theme(plot.title = element_text(face = "bold", hjust = 0.5))
}

p1 <- estimate_density(dfsub$Age) |>
  ggplot(aes(x = x, y = y)) +
  geom_area(fill = "#FF9800") +
  labs(x = "Age", y = "") +
  theme_modern()

p2 <- plot_waffle(dfsub, "Sex") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63", "Other" = "#FF9800"))

p3 <- plot_waffle(dfsub, "Sexual_Orientation")


p4 <- plot_waffle(dfsub, "Education") +
  scale_fill_viridis_d()

p5 <- dfsub |>
  group_by(Nationality) |>
  mutate(n = n()) |>
  ungroup() |>
  mutate(Nationality = fct_reorder(Nationality, desc(n))) |>
  ggplot(aes(Nationality)) +
  geom_bar(aes(fill = Nationality)) +
  scale_fill_viridis_d(guide = "none") + 
  theme_modern() +
  theme(axis.text.x = element_text(angle = 45, hjust = 1)) 

p6 <- plot_waffle(dfsub, "Ethnicity") +
  scale_fill_manual(values = c("Latino" = "#FF5722", "Asian" = "#FF9800", "Caucasian" = "#2196F3", "African" = "#4CAF50", "Jewish" = "#9C27B0", "Mixed" = "#795548"))

p7 <- plot_waffle(dfsub, "Screen_Resolution", title = "Screen Resolution") +
  scale_fill_pizza_d() +
  guides(fill = "none")

p8 <- plot_waffle(dfsub, "Device_OS", title = "Device OS") +
  scale_fill_bluebrown_d()

# p10 <- plot_waffle(dfsub, "Screen_Refresh") +
#   scale_fill_viridis_d()

patchwork::wrap_plots(list(p1, p2, p3, p5, p4, p6))

Results

Manipulation Check

Real / Fake

# plot(estimate_density(filter(df, Participant == "60dd7b03f1e72d38230df476_9yh9n")$Belief_Answer))
df |>
  mutate(Participant = fct_relevel(Participant, df |>
    group_by(Participant) |>
    summarize(Belief_Answer = mean(Belief_Answer)) |>
    ungroup() |>
    arrange(Belief_Answer) |>
    pull(Participant) |>
    as.character())) |>
  # mutate(Participant = fct_relevel(Participant, as.character(dfsub$Participant))) |>
  ggplot(aes(x = Belief_Answer, y = Participant, fill = Participant)) +
  ggdist::stat_slab(scale = 2, slab_alpha = 0.9, normalize = "groups", color = "black", size = 0.1) +
  geom_vline(xintercept = 0, linetype = "dotted") +
  scale_y_discrete(expand = c(0.02, 0)) +
  scale_x_continuous(
    limits = c(-1, 1),
    expand = c(0, 0),
    breaks = c(-0.95, 0, 0.95),
    label = c("Fake", "", "Real")
  ) +
  scale_fill_viridis_d() +
  labs(x = "Simulation Monitoring", y = "Participants", title = "Distribution of Reality Judgments") +
  guides(fill = "none") +
  see::theme_modern() +
  theme(
    axis.text.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "grey", color = "white") +
  ggside::scale_xsidey_continuous(expand = c(0, 0))

Colinearity

IVs <- c("Attractive", "Beauty", "Trustworthy", "Familiar")

preds <- data.frame()
dats <- data.frame()
for (x in IVs) {
  for (y in IVs) {
    if (x == y) next
    print(paste(y, "~", x))
    model <- glmmTMB::glmmTMB(as.formula(
      paste(y, "~", x, "* Sex * Stimulus_Interest + (1|Participant) + (1|Stimulus)")
    ),
    data = df,
    family = glmmTMB::beta_family()
    )

    # model <- mgcv::gamm(Real ~ s(Attractive) + Trustworthy,
    #                     random = list(Participant=~1, Stimulus=~1),
    #                     data = df,
    #                     family=mgcv::betar())

    pred <- estimate_relation(model, at = c(x, "Stimulus_Interest", "Sex"), length = 20)
    pred$y <- y
    pred <- data_rename(pred, x, "Score")
    pred$x <- x
    preds <- rbind(preds, pred)

    dats <- rbind(dats, data.frame(Score = df[[x]], Predicted = df[[y]], x = x, y = y, Sex = df$Sex))
  }
}
## [1] "Beauty ~ Attractive"
## [1] "Trustworthy ~ Attractive"
## [1] "Familiar ~ Attractive"
## [1] "Attractive ~ Beauty"
## [1] "Trustworthy ~ Beauty"
## [1] "Familiar ~ Beauty"
## [1] "Attractive ~ Trustworthy"
## [1] "Beauty ~ Trustworthy"
## [1] "Familiar ~ Trustworthy"
## [1] "Attractive ~ Familiar"
## [1] "Beauty ~ Familiar"
## [1] "Trustworthy ~ Familiar"

dats <- mutate(dats, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))
preds <- mutate(preds, x = fct_relevel(x, IVs), y = fct_relevel(y, IVs))

dats |>
  ggplot(aes(x = Score, y = Predicted)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  # geom_ribbon(data = preds, aes(ymin = CI_low, ymax = CI_high, group = Stimulus_SameSex), alpha = 0.3) +
  geom_line(data = preds, aes(color = Sex, linetype = Stimulus_Interest)) +
  scale_fill_gradientn(colors = c("white", "#FF9800", "#F44336"), guide = "none") +
  scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  scale_linetype_manual(values = c("TRUE" = "solid", "FALSE" = "dashed")) +
  scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  facet_grid(y ~ x, switch = "both") +
  theme_modern() +
  labs(title = "Collinearity in the Stimuli Ratings") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    axis.title.x = element_blank(),
    axis.title.y = element_blank(),
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggnewscale::new_scale_fill() +
  scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
  ggside::geom_xsidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::geom_ysidedensity(aes(fill = Sex), color = NA, alpha = 0.3) +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")

Effect of Delay

model <- glmmTMB::glmmTMB(Belief ~ Delay + (1 | Participant) + (1 | Stimulus),
  data = df,
  family = "binomial"
)
pred <- estimate_relation(model, at = "Delay", length = 20)

m_conf <- glmmTMB::glmmTMB(Belief_Confidence ~ Belief / Delay + ((Belief / Delay) | Participant) + (1 | Stimulus),
  data = df,
  family = glmmTMB::beta_family()
)
y_conf <- estimate_relation(m_conf, at = c("Delay", "Belief"), length = 20)
y_conf <- y_conf |>
  mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))


df |>
  ggplot(aes(x = Delay, y = Real)) +
  stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
  geom_hline(yintercept = 0.5, linetype = "dotted") +
  # geom_ribbon(data=y_conf, aes(y=Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = y_conf, aes(y = Predicted, group = Belief), linetype = "dashed", color = "red") +
  geom_ribbon(data = pred, aes(y = Predicted, ymin = CI_low, ymax = CI_high), alpha = 0.3) +
  geom_line(data = pred, aes(y = Predicted), color = "red") +
  scale_fill_gradientn(colors = c("white", "#795548"), guide = "none") +
  scale_x_continuous(expand = c(0, 0)) +
  scale_y_continuous(expand = c(0, 0), labels = scales::percent) +
  theme_modern() +
  labs(title = "Effect of Re-exposure Delay", x = "Minutes") +
  theme(
    aspect.ratio = 1,
    strip.background = element_blank(),
    strip.placement = "outside",
    plot.title = element_text(face = "bold", hjust = 0.5)
  ) +
  ggside::geom_xsidedensity(fill = "#795548", color = "white") +
  ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
  ggside::theme_ggside_void() +
  ggside::scale_ysidex_continuous(expand = c(0, 0)) +
  ggside::scale_xsidey_continuous(expand = c(0, 0)) +
  ggside::ggside(collapse = "all")


parameters::parameters(model)
## # Fixed Effects
## 
## Parameter   |  Log-Odds |       SE |         95% CI |     z |      p
## --------------------------------------------------------------------
## (Intercept) |      0.39 |     0.10 | [ 0.20,  0.58] |  3.94 | < .001
## Delay       | -6.62e-03 | 2.91e-03 | [-0.01,  0.00] | -2.27 | 0.023 
## 
## # Random Effects
## 
## Parameter                   | Coefficient
## -----------------------------------------
## SD (Intercept: Participant) |        0.65
## SD (Intercept: Stimulus)    |        0.59

Determinants of Reality

make_model <- function(df, var = "Attractive", formula = var, fill = "#2196F3") {
  # Models
  m_real <- glmmTMB::glmmTMB(as.formula(paste0("Belief ~ ", formula)),
    data = df,
    family = "binomial"
  )
  y_real <- estimate_relation(m_real, at = c(var, "Sex"), length = 21)
  # gam <- brms::brm(paste0("Belief ~ s(", var, ", by=Sex) + (1|Participant) + (1|Stimulus)"),
  #                  data=df,
  #                  algorithm="sampling",
  #                  family = "bernoulli")
  # trend <- estimate_relation(gam, at = c(var, "Sex"), length = 81, preserve_range=FALSE)
  # slope <- estimate_slopes(gam, trend=var, at = c(var, "Sex"), length = 81)
  # trend$Trend <- interpret_pd(slope$pd)
  # trend$group <- 0
  # trend$group[2:nrow(trend)] <- as.character(cumsum(ifelse(trend$Trend[2:nrow(trend)] == trend$Trend[1:nrow(trend)-1], 0, 1)))


  m_conf <- glmmTMB::glmmTMB(as.formula(paste0("Belief_Confidence ~ Belief /", formula)),
    data = df,
    family = glmmTMB::beta_family()
  )
  y_conf <- estimate_relation(m_conf, at = c(var, "Belief", "Sex"), length = 21)
  y_conf <- y_conf |>
    mutate_at(c("Predicted", "CI_low", "CI_high"), function(x) ifelse(y_conf$Belief == "Real", datawizard::rescale(x, range = c(0, 1), to = c(0.5, 1)), datawizard::rescale(x, range = c(1, 0), to = c(0, 0.5))))

  # Significance
  param <- parameters::parameters(m_real, effects = "fixed", keep = var)
  sig <- data.frame(
    x = 0.5,
    y = y_real[c(11, 32), "Predicted"] + c(0.05, -0.05),
    p = c(min(param$p[c(1, 3)]), min(param$p[c(2, 4)])),
    Sex = c("Female", "Male")
  )
  sig$label <- format_p(sig$p, stars_only = TRUE)

  # Plot
  p <- df |>
    ggplot(aes_string(x = var, y = "Real")) +
    stat_density_2d(aes(fill = ..density..), geom = "raster", contour = FALSE) +
    scale_fill_gradientn(colors = c("white", fill), guide = "none") +
    ggnewscale::new_scale_fill() +
    geom_hline(yintercept = 0.5, linetype = "dotted") +
    # geom_point2(alpha = 0.25, size = 4, color = "black") +
    geom_line(data = y_conf, aes(y = Predicted, group = interaction(Belief, Sex), color = Sex), linetype = "dashed") +
    geom_ribbon(data = y_real, aes(y = Predicted, group = Sex, fill = Sex, ymin = CI_low, ymax = CI_high), alpha = 1 / 3) +
    geom_line(data = y_real, aes(y = Predicted, color = Sex), size=1) +
    # geom_ribbon(data = trend, aes(y = Predicted, group=Sex, fill=Sex, ymin = CI_low, ymax = CI_high), alpha = 1/6) +
    # geom_line(data = trend, aes(y = Predicted, color=Sex, linetype=Trend, group=interaction(Sex, group)), size=0.6) +
    geom_text(data = sig, aes(y = y, x = x, label = label, color = Sex), size = 8) +
    scale_color_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_fill_manual(values = c("Male" = "#2196F3", "Female" = "#E91E63")) +
    scale_x_continuous(expand = c(0, 0), labels = scales::percent) +
    scale_y_continuous(expand = c(0, 0), breaks = c(0, 0.25, 0.5, 0.75, 1), labels = c("Fake", "25%", "50%", "75%", "Real")) +
    labs(y = "Simulation Monitoring") +
    guides(fill = guide_legend(override.aes = list(alpha = 1))) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fill, color = "white") +
    ggside::geom_ysidedensity(fill = "#9C27B0", color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))

  list(p = p, model_belief = m_real, model_confidence = m_conf)
}

rez_at <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Attractive, 2) + (1|Participant) + (1|Stimulus)",
  var = "Attractive", fill = "#F44336"
)
rez_gl <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Beauty, 2) + Trustworthy + (1|Participant) + (1|Stimulus)",
  var = "Beauty", fill = "#E91E63"
)
rez_tr <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Trustworthy, 2) + Beauty + (1|Participant) + (1|Stimulus)",
  var = "Trustworthy", fill = "#4CAF50"
)
rez_fa <- make_model(filter(df, Stimulus_Interest == TRUE),
  formula = "Sex / poly(Familiar, 2) + (1|Participant) + (1|Stimulus)",
  var = "Familiar", fill = "#2196F3"
)



fig1a <- (rez_at$p +
  theme(axis.text.x = element_blank()) +
  labs(x = "Attractiveness") |
  rez_gl$p +
    labs(x = "Beauty") +
    theme(
      axis.text.x = element_blank(),
      axis.title.y = element_blank(),
      axis.text.y = element_blank()
    )
) /
  (rez_tr$p +
    labs(x = "Trustworthiness") |
    rez_fa$p +
      labs(x = "Familiarity") +
      theme(
        axis.text.y = element_blank(),
        axis.title.y = element_blank()
      )
  ) +
  plot_annotation(title = "Determinants of Reality Beliefs", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5))) +
  plot_layout(guides = "collect") &
  theme(legend.position='top', legend.title = element_blank())
fig1a

parameters::parameters(rez_at$model_belief, effects = "fixed", keep = "Attractive")
## # Fixed Effects
## 
## Parameter                           | Log-Odds |   SE |         95% CI |    z |      p
## --------------------------------------------------------------------------------------
## Sex [Female] * poly(Attractive, 2)1 |     1.00 | 3.64 | [-6.13,  8.13] | 0.28 | 0.783 
## Sex [Male] * poly(Attractive, 2)1   |    16.37 | 4.39 | [ 7.76, 24.98] | 3.73 | < .001
## Sex [Female] * poly(Attractive, 2)2 |     7.77 | 3.25 | [ 1.41, 14.13] | 2.40 | 0.017 
## Sex [Male] * poly(Attractive, 2)2   |     4.61 | 5.22 | [-5.61, 14.83] | 0.88 | 0.377
performance::r2(rez_at$model_belief)
## # R2 for Mixed Models
## 
##   Conditional R2: 0.197
##      Marginal R2: 0.028
performance::icc(rez_at$model_belief, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.086
## Stimulus    | 0.087
parameters::parameters(rez_at$model_confidence, effects = "fixed", keep = "Attractive")
## # Fixed Effects
## 
## Parameter                                        | Coefficient |   SE |          95% CI |     z |     p
## -------------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Attractive, 2)1 |        0.98 | 2.59 | [ -4.09,  6.06] |  0.38 | 0.704
## Belief [Real] * SexFemale * poly(Attractive, 2)1 |        2.13 | 1.87 | [ -1.54,  5.81] |  1.14 | 0.255
## Belief [Fake] * SexMale * poly(Attractive, 2)1   |        2.65 | 3.41 | [ -4.02,  9.33] |  0.78 | 0.436
## Belief [Real] * SexMale * poly(Attractive, 2)1   |        0.78 | 2.64 | [ -4.39,  5.94] |  0.30 | 0.768
## Belief [Fake] * SexFemale * poly(Attractive, 2)2 |        3.35 | 2.33 | [ -1.21,  7.92] |  1.44 | 0.150
## Belief [Real] * SexFemale * poly(Attractive, 2)2 |        4.38 | 1.74 | [  0.96,  7.79] |  2.51 | 0.012
## Belief [Fake] * SexMale * poly(Attractive, 2)2   |       -8.85 | 4.57 | [-17.81,  0.11] | -1.94 | 0.053
## Belief [Real] * SexMale * poly(Attractive, 2)2   |        5.11 | 2.77 | [ -0.32, 10.53] |  1.85 | 0.065

parameters::parameters(rez_gl$model_belief, effects = "fixed", keep = "Beauty")
## # Fixed Effects
## 
## Parameter                       | Log-Odds |   SE |         95% CI |     z |     p
## ----------------------------------------------------------------------------------
## Sex [Female] * poly(Beauty, 2)1 |    -0.38 | 3.64 | [-7.52,  6.76] | -0.10 | 0.917
## Sex [Male] * poly(Beauty, 2)1   |     9.93 | 4.12 | [ 1.86, 18.00] |  2.41 | 0.016
## Sex [Female] * poly(Beauty, 2)2 |     3.30 | 3.30 | [-3.17,  9.77] |  1.00 | 0.317
## Sex [Male] * poly(Beauty, 2)2   |     7.60 | 4.41 | [-1.04, 16.24] |  1.72 | 0.085
performance::r2(rez_gl$model_belief)
## # R2 for Mixed Models
## 
##   Conditional R2: 0.192
##      Marginal R2: 0.031
performance::icc(rez_gl$model_belief, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.087
## Stimulus    | 0.079
parameters::parameters(rez_gl$model_confidence, effects = "fixed", keep = "Beauty")
## # Fixed Effects
## 
## Parameter                                    | Coefficient |   SE |          95% CI |     z |     p
## ---------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Beauty, 2)1 |       -1.81 | 2.45 | [ -6.60,  2.99] | -0.74 | 0.460
## Belief [Real] * SexFemale * poly(Beauty, 2)1 |        2.54 | 2.00 | [ -1.38,  6.46] |  1.27 | 0.203
## Belief [Fake] * SexMale * poly(Beauty, 2)1   |       -1.83 | 3.28 | [ -8.25,  4.59] | -0.56 | 0.576
## Belief [Real] * SexMale * poly(Beauty, 2)1   |        2.05 | 2.38 | [ -2.62,  6.72] |  0.86 | 0.390
## Belief [Fake] * SexFemale * poly(Beauty, 2)2 |        6.61 | 2.37 | [  1.98, 11.25] |  2.79 | 0.005
## Belief [Real] * SexFemale * poly(Beauty, 2)2 |        2.57 | 1.96 | [ -1.27,  6.40] |  1.31 | 0.190
## Belief [Fake] * SexMale * poly(Beauty, 2)2   |       -5.71 | 3.34 | [-12.26,  0.83] | -1.71 | 0.087
## Belief [Real] * SexMale * poly(Beauty, 2)2   |        4.55 | 2.46 | [ -0.28,  9.38] |  1.85 | 0.065

parameters::parameters(rez_tr$model_belief, effects = "fixed", keep = "Trustworthy")
## # Fixed Effects
## 
## Parameter                            | Log-Odds |   SE |         95% CI |     z |     p
## ---------------------------------------------------------------------------------------
## Sex [Female] * poly(Trustworthy, 2)1 |    11.58 | 3.79 | [ 4.15, 19.01] |  3.05 | 0.002
## Sex [Male] * poly(Trustworthy, 2)1   |     6.14 | 3.78 | [-1.28, 13.55] |  1.62 | 0.105
## Sex [Female] * poly(Trustworthy, 2)2 |    -0.07 | 3.92 | [-7.75,  7.61] | -0.02 | 0.986
## Sex [Male] * poly(Trustworthy, 2)2   |     0.26 | 3.96 | [-7.51,  8.02] |  0.07 | 0.948
performance::r2(rez_tr$model_belief)
## # R2 for Mixed Models
## 
##   Conditional R2: 0.183
##      Marginal R2: 0.027
performance::icc(rez_tr$model_belief, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.085
## Stimulus    | 0.076
parameters::parameters(rez_tr$model_confidence, effects = "fixed", keep = "Trustworthy")
## # Fixed Effects
## 
## Parameter                                         | Coefficient |   SE |         95% CI |     z |     p
## -------------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Trustworthy, 2)1 |        2.09 | 2.46 | [-2.73,  6.90] |  0.85 | 0.396
## Belief [Real] * SexFemale * poly(Trustworthy, 2)1 |        1.22 | 2.53 | [-3.74,  6.19] |  0.48 | 0.629
## Belief [Fake] * SexMale * poly(Trustworthy, 2)1   |       -3.23 | 2.80 | [-8.73,  2.26] | -1.15 | 0.249
## Belief [Real] * SexMale * poly(Trustworthy, 2)1   |        0.43 | 2.24 | [-3.95,  4.82] |  0.19 | 0.847
## Belief [Fake] * SexFemale * poly(Trustworthy, 2)2 |        1.34 | 2.64 | [-3.83,  6.51] |  0.51 | 0.612
## Belief [Real] * SexFemale * poly(Trustworthy, 2)2 |        6.64 | 2.41 | [ 1.92, 11.37] |  2.75 | 0.006
## Belief [Fake] * SexMale * poly(Trustworthy, 2)2   |       -3.99 | 2.81 | [-9.49,  1.52] | -1.42 | 0.156
## Belief [Real] * SexMale * poly(Trustworthy, 2)2   |        0.57 | 2.32 | [-3.97,  5.12] |  0.25 | 0.805

parameters::parameters(rez_fa$model_belief, effects = "fixed", keep = "Familiar")
## # Fixed Effects
## 
## Parameter                         | Log-Odds |   SE |          95% CI |     z |     p
## -------------------------------------------------------------------------------------
## Sex [Female] * poly(Familiar, 2)1 |     3.95 | 4.00 | [ -3.88, 11.78] |  0.99 | 0.323
## Sex [Male] * poly(Familiar, 2)1   |     9.46 | 4.97 | [ -0.27, 19.20] |  1.90 | 0.057
## Sex [Female] * poly(Familiar, 2)2 |    -2.14 | 3.71 | [ -9.42,  5.14] | -0.58 | 0.564
## Sex [Male] * poly(Familiar, 2)2   |    -2.73 | 4.60 | [-11.74,  6.29] | -0.59 | 0.554
performance::r2(rez_fa$model_belief)
## # R2 for Mixed Models
## 
##   Conditional R2: 0.199
##      Marginal R2: 0.011
performance::icc(rez_fa$model_belief, by_group = TRUE)
## # ICC by Group
## 
## Group       |   ICC
## -------------------
## Participant | 0.106
## Stimulus    | 0.085
parameters::parameters(rez_fa$model_confidence, effects = "fixed", keep = "Familiar")
## # Fixed Effects
## 
## Parameter                                      | Coefficient |   SE |          95% CI |     z |      p
## ------------------------------------------------------------------------------------------------------
## Belief [Fake] * SexFemale * poly(Familiar, 2)1 |        5.14 | 2.64 | [ -0.04, 10.31] |  1.95 | 0.052 
## Belief [Real] * SexFemale * poly(Familiar, 2)1 |       -1.06 | 2.09 | [ -5.16,  3.04] | -0.51 | 0.612 
## Belief [Fake] * SexMale * poly(Familiar, 2)1   |      -12.38 | 3.67 | [-19.57, -5.19] | -3.37 | < .001
## Belief [Real] * SexMale * poly(Familiar, 2)1   |        9.83 | 2.98 | [  4.00, 15.67] |  3.30 | < .001
## Belief [Fake] * SexFemale * poly(Familiar, 2)2 |        0.55 | 2.45 | [ -4.26,  5.36] |  0.22 | 0.822 
## Belief [Real] * SexFemale * poly(Familiar, 2)2 |       -0.73 | 2.14 | [ -4.93,  3.46] | -0.34 | 0.732 
## Belief [Fake] * SexMale * poly(Familiar, 2)2   |        7.06 | 4.07 | [ -0.92, 15.05] |  1.73 | 0.083 
## Belief [Real] * SexMale * poly(Familiar, 2)2   |       -1.93 | 2.64 | [ -7.12,  3.25] | -0.73 | 0.464

Interaction with Self-Attractiveness

cor_test(dfsub, "SelfAttractiveness1", "SelfAttractiveness2")
## Parameter1          |          Parameter2 |    r |       95% CI | t(98) |         p
## -----------------------------------------------------------------------------------
## SelfAttractiveness1 | SelfAttractiveness2 | 0.88 | [0.82, 0.92] | 18.19 | < .001***
## 
## Observations: 100

df$Self_Attractiveness <- rowMeans(df[c("SelfAttractiveness1", "SelfAttractiveness2")])

m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Attractive, 2) * Self_Attractiveness) + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)

parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness")
## # Fixed Effects
## 
## Parameter                                                 | Log-Odds |    SE |          95% CI |     z |     p
## --------------------------------------------------------------------------------------------------------------
## Sex [Female] * Self Attractiveness                        |     1.32 |  0.96 | [ -0.56,  3.21] |  1.38 | 0.169
## Sex [Male] * Self Attractiveness                          |    -2.21 |  1.64 | [ -5.42,  1.00] | -1.35 | 0.178
## Sex [Female] * poly(Attractive, 2)1 * Self Attractiveness |   -22.26 | 21.07 | [-63.56, 19.04] | -1.06 | 0.291
## Sex [Male] * poly(Attractive, 2)1 * Self Attractiveness   |    32.32 | 33.75 | [-33.83, 98.46] |  0.96 | 0.338
## Sex [Female] * poly(Attractive, 2)2 * Self Attractiveness |    12.20 | 14.19 | [-15.61, 40.01] |  0.86 | 0.390
## Sex [Male] * poly(Attractive, 2)2 * Self Attractiveness   |   -14.63 | 32.37 | [-78.07, 48.80] | -0.45 | 0.651

m_real <- glmmTMB::glmmTMB(Belief ~ Sex / (poly(Beauty, 2) * Self_Attractiveness) + Trustworthy + (1 | Participant) + (1 | Stimulus),
  data = filter(df, Stimulus_Interest == TRUE),
  family = "binomial"
)

parameters::parameters(m_real, effects = "fixed", keep = "Self_Attractiveness")
## # Fixed Effects
## 
## Parameter                                             | Log-Odds |    SE |           95% CI |     z |     p
## -----------------------------------------------------------------------------------------------------------
## Sex [Female] * Self Attractiveness                    |     0.98 |  1.00 | [ -0.97,   2.93] |  0.98 | 0.326
## Sex [Male] * Self Attractiveness                      |    -1.79 |  1.69 | [ -5.10,   1.52] | -1.06 | 0.290
## Sex [Female] * poly(Beauty, 2)1 * Self Attractiveness |   -26.06 | 15.71 | [-56.84,   4.72] | -1.66 | 0.097
## Sex [Male] * poly(Beauty, 2)1 * Self Attractiveness   |    43.68 | 28.82 | [-12.80, 100.17] |  1.52 | 0.130
## Sex [Female] * poly(Beauty, 2)2 * Self Attractiveness |     8.39 | 13.18 | [-17.45,  34.22] |  0.64 | 0.525
## Sex [Male] * poly(Beauty, 2)2 * Self Attractiveness   |    -6.84 | 29.31 | [-64.28,  50.61] | -0.23 | 0.816

Inter-Individual Correlates

IPIP-6

make_correlation <- function(x, y) {
  cor <- correlation::correlation(x,
    y,
    bayesian = TRUE,
    bayesian_prior = "medium.narrow",
    sort = TRUE
  ) |>
    datawizard::data_remove(c("ROPE_Percentage"))
  cor$`BF (Spearman)` <- format_bf(
    correlation::correlation(
      x, y,
      bayesian = TRUE,
      ranktransform = TRUE,
      bayesian_prior = "medium.narrow"
    )$BF,
    name = NULL, stars = TRUE
  )
  cor |>
    arrange(desc(BF))
}


plot_correlation <- function(dfsub, x = "Confidence_Real", y = "IPIP6_Openness", xlab = x, ylab = y, fill = "grey", fillx = "purple") {
  param <- cor_test(dfsub, x, y, bayesian = TRUE)

  # Format stat output
  r <- str_replace(str_remove(insight::format_value(param$rho), "^0+"), "^-0+", "-")
  CI_low <- str_replace(str_remove(insight::format_value(param$CI_low), "^0+"), "^-0+", "-")
  CI_high <- str_replace(str_remove(insight::format_value(param$CI_high), "^0+"), "^-0+", "-")

  stat <- paste0("italic(r)~'= ", r, ", 95% CI [", CI_low, ", ", CI_high, "], BF'['10']~'", paste0(insight::format_bf(param$BF, name = "")), "'")

  label <- data.frame(
    x = min(dfsub[[x]], na.rm = TRUE),
    y = max(dfsub[[y]], na.rm = TRUE),
    label = stat
  )

  # Plot
  dfsub |>
    ggplot(aes_string(x = x, y = y)) +
    geom_point2(
      size = 3,
      color = fillx,
      # color = DVs[x],
      alpha = 2 / 3
    ) +
    geom_smooth(method = "lm", color = "black", formula = "y ~ x", alpha = 0.3) +
    labs(y = ylab, x = xlab) +
    geom_label(data = label, aes(x = x, y = y), label = str2expression(label$label), hjust = 0, vjust = 1, size=rel(3.5)) +
    theme_modern(axis.title.space = 5) +
    ggside::geom_xsidedensity(fill = fillx, color = "white") +
    ggside::geom_ysidedensity(fill = fill, color = "white") +
    ggside::theme_ggside_void() +
    ggside::scale_ysidex_continuous(expand = c(0, 0)) +
    ggside::scale_xsidey_continuous(expand = c(0, 0))
}

sr <- c("Confidence_Fake", "Confidence_Real", "n_Real")

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IPIP")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |            Parameter2 |   rho |         95% CI |      pd |               Prior |    BF | BF (Spearman)
## ------------------------------------------------------------------------------------------------------------------------
## Confidence_Real | IPIP6_HonestyHumility | -0.21 | [-0.38, -0.02] | 98.65%* | Beta (5.20 +- 5.20) | 3.57* |         3.55*
## Confidence_Fake |        IPIP6_Openness |  0.16 | [-0.02,  0.35] |  95.40% | Beta (5.20 +- 5.20) |  1.40 |          1.12
## 
## Observations: 100

AI

rez <- parameters::n_factors(select(dfsub, starts_with("AI")))
plot(rez)


efa <- parameters::factor_analysis(select(dfsub, starts_with("AI")), n = 3, rotation = "varimax", sort = TRUE)
efa
## # Rotated loadings from Factor Analysis (varimax-rotation)
## 
## Variable              |  MR1  |    MR2    |    MR3    | Complexity | Uniqueness
## -------------------------------------------------------------------------------
## AI_4_DailyLife        | 0.88  |   0.07    |   0.15    |    1.07    |    0.20   
## AI_8_Exciting         | 0.79  |   0.20    |   0.14    |    1.20    |    0.31   
## AI_9_Applications     | 0.79  |   0.09    |   0.17    |    1.12    |    0.34   
## AI_7_RealisticVideos  | 0.14  |   0.74    | -4.43e-03 |    1.07    |    0.43   
## AI_5_ImitatingReality | 0.29  |   0.63    |   0.05    |    1.42    |    0.52   
## AI_3_VideosReal       | -0.15 |   0.50    |   -0.12   |    1.30    |    0.71   
## AI_1_RealisticImages  | 0.18  |   0.49    |   0.19    |    1.56    |    0.69   
## AI_2_Unethical        | 0.18  | -7.70e-04 |   0.78    |    1.11    |    0.35   
## AI_6_Dangerous        | 0.17  |   -0.12   |   0.62    |    1.23    |    0.57   
## AI_10_FaceErrors      | 0.02  |   0.07    |   0.25    |    1.14    |    0.93   
## 
## The 3 latent factors (varimax rotation) accounted for 49.60% of the total variance of the original data (MR1 = 22.50%, MR2 = 15.19%, MR3 = 11.91%).
dfsub <- predict(efa, names = c("AI_Enthusiasm", "AI_Realness", "AI_Danger")) |>
  cbind(dfsub)

r <- make_correlation(dfsub[sr], select(dfsub, AI_Enthusiasm, AI_Realness, AI_Danger))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |    Parameter2 |   rho |        95% CI |       pd |               Prior |      BF | BF (Spearman)
## ------------------------------------------------------------------------------------------------------------------
## Confidence_Fake | AI_Enthusiasm |  0.27 | [ 0.09, 0.44] | 99.75%** | Beta (5.20 +- 5.20) | 23.04** |      37.85***
## Confidence_Real | AI_Enthusiasm |  0.24 | [ 0.07, 0.41] | 99.50%** | Beta (5.20 +- 5.20) |   8.00* |       10.91**
## Confidence_Fake |     AI_Danger | -0.18 | [-0.35, 0.01] |   96.70% | Beta (5.20 +- 5.20) |    1.61 |          1.01
## n_Real          |     AI_Danger |  0.17 | [-0.01, 0.34] |   96.67% | Beta (5.20 +- 5.20) |    1.49 |         0.943
## 
## Observations: 100

Social Anxiety

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("Social_")))
filter(r, BF > 1)

Intolerance to Uncertainty

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("IUS_")))
filter(r, BF > 1)

Narcissism

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("FFNI_")))
filter(r, BF > 1)
## # Correlation Matrix (pearson-method)
## 
## Parameter1      |              Parameter2 |  rho |        95% CI |       pd |               Prior |      BF | BF (Spearman)
## ---------------------------------------------------------------------------------------------------------------------------
## Confidence_Real |     FFNI_AcclaimSeeking | 0.26 | [ 0.09, 0.43] | 99.67%** | Beta (5.20 +- 5.20) | 14.38** |      53.44***
## Confidence_Fake |     FFNI_AcclaimSeeking | 0.22 | [ 0.04, 0.40] |  98.85%* | Beta (5.20 +- 5.20) |   4.52* |         6.26*
## Confidence_Real | FFNI_GrandioseFantasies | 0.22 | [ 0.02, 0.38] | 99.08%** | Beta (5.20 +- 5.20) |   4.18* |         6.07*
## n_Real          |     FFNI_AcclaimSeeking | 0.19 | [ 0.00, 0.36] |  97.70%* | Beta (5.20 +- 5.20) |    2.21 |          2.78
## Confidence_Fake | FFNI_GrandioseFantasies | 0.19 | [ 0.00, 0.37] |  97.10%* | Beta (5.20 +- 5.20) |    1.93 |          1.33
## Confidence_Real |      FFNI_ReactiveAnger | 0.15 | [-0.03, 0.32] |   94.80% | Beta (5.20 +- 5.20) |    1.12 |          1.92
## Confidence_Fake |   FFNI_Manipulativeness | 0.15 | [-0.05, 0.31] |   93.95% | Beta (5.20 +- 5.20) |    1.04 |         0.776
## 
## Observations: 100

Paranoid Beliefs

r <- make_correlation(dfsub[sr], select(dfsub, starts_with("GPTS_")))
filter(r, BF > 1)

p1 <- plot_correlation(dfsub,
  x = "IPIP6_HonestyHumility",
  y = "Confidence_Real",
  ylab = "Confidence that the stimulus is real",
  xlab = "Honesty-Humility",
  fillx = "#00BCD4",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p2 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p3 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "AI_Enthusiasm",
  ylab = "Confidence that the stimulus is real",
  xlab = "Enthusiasm about AI technology",
  fillx = "#607D8B",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p4 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

p5 <- plot_correlation(dfsub,
  y = "Confidence_Fake",
  x = "FFNI_AcclaimSeeking",
  ylab = "Confidence that the stimulus is fake",
  xlab = "Narcissism (Acclaim Seeking)",
  fillx = "#FF9800",
  fill = "#3F51B5"
) + 
  scale_y_continuous(labels=scales::percent)

p6 <- plot_correlation(dfsub,
  y = "Confidence_Real",
  x = "FFNI_GrandioseFantasies",
  ylab = "Confidence that the stimulus is real",
  xlab = "Narcissism (Grandiose Fantasies)",
  fillx = "#FFC107",
  fill = "#D81B60"
) + 
  scale_y_continuous(labels=scales::percent)

fig <- wrap_elements(fig1a) /
  wrap_elements(
    ((p3 / p2) | (p1 / p6) | (p4 / p5)) + 
  plot_annotation(title = "Personality Correlates of Simulation Monitoring Tendencies", theme = theme(plot.title = element_text(face = "bold", hjust = 0.5)))
  ) +
  plot_layout(heights = c(1.1, 0.9))

ggsave("figures/Figure2.png", width=fig.height * 1.8, height=fig.width * 1.5)

Face Attractiveness and the Sense of Reality

2022-09-12